home *** CD-ROM | disk | FTP | other *** search
/ QRZ! Ham Radio 8 / QRZ Ham Radio Callsign Database - Volume 8.iso / pc / files / ant_nec / nec81tar.z / nec81tar / rdpat.f < prev    next >
Text File  |  1991-05-13  |  21KB  |  726 lines
  1. C $TITLE: 'RDPAT'
  2. C $NOFLOATCALLS
  3. C
  4.       SUBROUTINE RDPAT(CUR,GAIN,AIR,AII,BIR,BII,CIR,CII,SI,CAB,SAB,
  5.      1 BI,SALP,X,Y,Z,LD,LD3,LD4,IW)
  6. C     COMPUTE RADIATION PATTERN, GAIN, NORMALIZED GAIN
  7. CLARGE: CUR
  8.       COMPLEX CUR
  9.       COMPLEX*16 ETH,EPH,ERD
  10.       COMPLEX*16 ZRATI,ZRATI2,T1,FRATI
  11.       REAL*8 PI,TA,TD,IGNTP,IGAX,IGTP,HCIR,HBLK,HPOL,HCLIF,ISENS
  12.       REAL*8 ATGN2,CANG,DB10,TSTOR1,TSTOR2,GCOP,GCON,ETHA,ETHM,ETHM2
  13.       REAL*8 EPHA,EPHM,EPHM2,DFAZ,DFAZ2,CDFAZ,AIR,AII,BIR,BII,CIR,CII
  14.       REAL*8 TILTA,STILTA,AXRAT,EMINR2,EMAJR2,GNMN,GNMJ
  15.          REAL*8 GAIN
  16. C     INTEGER HPOL,HBLK,HCIR,HCLIF
  17.       INTEGER*4 N1,N2,N,NP,M1,M2,M,MP,IPSYM
  18.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  19.       COMMON/SAVE/ KCOM,COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ
  20.       COMMON/GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,
  21.      1 IFAR,IPERF,T1,T2
  22.       COMMON/FPAT/NTH,NPH,IPD,IAVP,INOR,IAX,THETS,PHIS,DTH,DPH,RFLD,
  23.      1 GNOR,CLT,CHT,EPSR2,SIG2,IXTYP,XPR6,PINR,PNLR,PLOSS,NEAR,NFEH,
  24.      2 NRX,NRY,NRZ,XNR,YNR,ZNR,DXNR,DYNR,DZNR
  25.       COMMON/PLOT/ IPLP1,IPLP2,IPLP3,IPLP4
  26.       DIMENSION CUR(LD3),GAIN(LD4)
  27.       DIMENSION CAB(LD),SAB(LD),SI(LD),BI(LD),SALP(LD),X(LD),Y(LD),Z(LD)
  28.       DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
  29.       DIMENSION IGTP(4), IGAX(4), IGNTP(10), HPOL(3)
  30. C***
  31.       DATA HPOL/'LINEAR','RIGHT','LEFT'/,HBLK,HCIR/' ','CIRCLE'/
  32.       DATA IGTP/'    - ','POWER ','- DIRE','CTIVE '/
  33.       DATA IGAX/' MAJOR',' MINOR',' VERT.',' HOR. '/
  34.       DATA IGNTP/' MAJOR',' AXIS ',' MINOR',' AXIS ','   VER','TICAL ','
  35.      1 HORIZ','ONTAL ','      ','TOTAL '/
  36.       DATA PI,TA,TD/3.141592654D0,1.745329252D-02,57.29577951D0/
  37. C**
  38.       DATA NORMAX/1200/
  39. C**
  40.       IF (IFAR.LT.2) GO TO 2
  41.       WRITE(IW,35)
  42.       IF (IFAR.LE.3) GO TO 1
  43.       WRITE(IW,36)  NRADL,SCRWLT,SCRWRT
  44.       IF (IFAR.EQ.4) GO TO 2
  45. 1     IF (IFAR.EQ.2.OR.IFAR.EQ.5) HCLIF=HPOL(1)
  46.       IF (IFAR.EQ.3.OR.IFAR.EQ.6) HCLIF=HCIR
  47.       CL=CLT/WLAM
  48.       CH=CHT/WLAM
  49.       ZRATI2=CDSQRT(1.D0/DCMPLX(EPSR2,-SIG2*WLAM*59.96))
  50.       WRITE(IW,37)  HCLIF,CLT,CHT,EPSR2,SIG2
  51. 2     IF (IFAR.NE.1) GO TO 3
  52.       WRITE(IW,41)
  53.       GO TO 5
  54. 3     I=2*IPD+1
  55.       J=I+1
  56.       ITMP1=2*IAX+1
  57.       ITMP2=ITMP1+1
  58.       WRITE(IW,38)
  59.       IF (RFLD.LT.1.E-20) GO TO 4
  60.       EXRM=1./RFLD
  61.       EXRA=RFLD/WLAM
  62.       EXRA=-360.*(EXRA-AINT(EXRA))
  63.       WRITE(IW,39)  RFLD,EXRM,EXRA
  64. 4     WRITE(IW,40)  IGTP(I),IGTP(J),IGAX(ITMP1),IGAX(ITMP2)
  65. 5     IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) GO TO 7
  66.       IF (IXTYP.EQ.4) GO TO 6
  67.       PRAD=0.
  68.       GCON=4.*PI/(1.+XPR6*XPR6)
  69.       GCOP=GCON
  70.       GO TO 8
  71. 6     PINR=394.51*XPR6*XPR6*WLAM*WLAM
  72. 7     GCOP=WLAM*WLAM*2.*PI/(376.73*PINR)
  73.       PRAD=PINR-PLOSS-PNLR
  74.       GCON=GCOP
  75.       IF (IPD.NE.0) GCON=GCON*PINR/PRAD
  76. 8     I=0
  77.       GMAX=-1.E10
  78.       PINT=0.
  79.       TMP1=DPH*TA
  80.       TMP2=.5*DTH*TA
  81.       PHI=PHIS-DPH
  82.       DO 29 KPH=1,NPH
  83.       PHI=PHI+DPH
  84.       PHA=PHI*TA
  85.       THET=THETS-DTH
  86.       DO 29 KTH=1,NTH
  87.       THET=THET+DTH
  88.       IF (KSYMP.EQ.2.AND.THET.GT.90.01.AND.IFAR.NE.1) GO TO 29
  89.       THA=THET*TA
  90.       IF (IFAR.EQ.1) GO TO 9
  91.       CALL FFLD (CUR,THA,PHA,ETH,EPH,X,Y,Z,SI,BI,
  92.      1 SALP,AIR,AII,BIR,BII,CIR,CII,CAB,SAB,LD,LD3)
  93. C**
  94.       GO TO 10
  95. 9     CALL GFLD(RFLD/WLAM,PHA,THET/WLAM,ETH,EPH,ERD,ZRATI,KSYMP,LD,
  96.      1 LD3,X,Y,Z,SI,BI,SALP,AIR,AII,BIR,BII,CIR,CII,CUR,CAB,SAB)
  97. C**
  98. C      ERDM=CABS(ERD)
  99.       ERDM=ZABS(ERD)
  100.       ERDA=CANG(ERD)
  101. 10    ETHM2=DREAL(ETH*DCONJG(ETH))
  102.       ETHM=DSQRT(ETHM2)
  103.       ETHA=CANG(ETH)
  104.       EPHM2=DREAL(EPH*DCONJG(EPH))
  105.       EPHM=DSQRT(EPHM2)
  106.       EPHA=CANG(EPH)
  107.       IF (IFAR.EQ.1) GO TO 28
  108. C     ELLIPTICAL POLARIZATION CALC.
  109.       IF (ETHM2.GT.1.E-20.OR.EPHM2.GT.1.E-20) GO TO 11
  110.       TILTA=0.
  111.       EMAJR2=0.
  112.       EMINR2=0.
  113.       AXRAT=0.
  114.       ISENS=HBLK
  115.       GO TO 16
  116. 11    DFAZ=EPHA-ETHA
  117.       IF (EPHA.LT.0.) GO TO 12
  118.       DFAZ2=DFAZ-360.
  119.       GO TO 13
  120. 12    DFAZ2=DFAZ+360.
  121. 13    IF (ABS(DFAZ).GT.ABS(DFAZ2)) DFAZ=DFAZ2
  122.       CDFAZ=DCOS(DFAZ*TA)
  123.       TSTOR1=ETHM2-EPHM2
  124.       TSTOR2=2.*EPHM*ETHM*CDFAZ
  125.       TILTA=.5*ATGN2(TSTOR2,TSTOR1)
  126.       STILTA=DSIN(TILTA)
  127.       TSTOR1=TSTOR1*STILTA*STILTA
  128.       TSTOR2=TSTOR2*STILTA*DCOS(TILTA)
  129.       EMAJR2=-TSTOR1+TSTOR2+ETHM2
  130.       EMINR2=TSTOR1-TSTOR2+EPHM2
  131.       IF (EMINR2.LT.0.) EMINR2=0.
  132.       AXRAT=DSQRT(EMINR2/EMAJR2)
  133.       TILTA=TILTA*TD
  134.       IF (AXRAT.GT.1.D-5) GO TO 14
  135.       ISENS=HPOL(1)
  136.       GO TO 16
  137. 14    IF (DFAZ.GT.0.) GO TO 15
  138.       ISENS=HPOL(2)
  139.       GO TO 16
  140. 15    ISENS=HPOL(3)
  141. 16    GNMJ=DB10(GCON*EMAJR2)
  142.       GNMN=DB10(GCON*EMINR2)
  143.       GNV=DB10(GCON*ETHM2)
  144.       GNH=DB10(GCON*EPHM2)
  145.       GTOT=DB10(GCON*(ETHM2+EPHM2))
  146.       IF (INOR.LT.1) GO TO 23
  147.       I=I+1
  148.       IF (I.GT.NORMAX) GO TO 23
  149.       GO TO (17,18,19,20,21), INOR
  150. 17    TSTOR1=GNMJ
  151.       GO TO 22
  152. 18    TSTOR1=GNMN
  153.       GO TO 22
  154. 19    TSTOR1=GNV
  155.       GO TO 22
  156. 20    TSTOR1=GNH
  157.       GO TO 22
  158. 21    TSTOR1=GTOT
  159. 22    GAIN(I)=TSTOR1
  160.       IF (TSTOR1.GT.GMAX) GMAX=TSTOR1
  161. 23    IF (IAVP.EQ.0) GO TO 24
  162.       TSTOR1=GCOP*(ETHM2+EPHM2)
  163.       TMP3=THA-TMP2
  164.       TMP4=THA+TMP2
  165.       IF (KTH.EQ.1) TMP3=THA
  166.       IF (KTH.EQ.NTH) TMP4=THA
  167. C      DA=ABS(TMP1*(DCOS(TMP3)-DCOS(TMP4)))
  168.       DA=ABS(TMP1*(COS(TMP3)-COS(TMP4)))
  169.       IF (KPH.EQ.1.OR.KPH.EQ.NPH) DA=.5*DA
  170.       PINT=PINT+TSTOR1*DA
  171.       IF (IAVP.EQ.2) GO TO 29
  172. 24    IF (IAX.EQ.1) GO TO 25
  173.       TMP5=GNMJ
  174.       TMP6=GNMN
  175.       GO TO 26
  176. 25    TMP5=GNV
  177.       TMP6=GNH
  178. 26    ETHM=ETHM*WLAM
  179.       EPHM=EPHM*WLAM
  180.       IF (RFLD.LT.1.E-20) GO TO 27
  181.       ETHM=ETHM*EXRM
  182.       ETHA=ETHA+EXRA
  183.       EPHM=EPHM*EXRM
  184.       EPHA=EPHA+EXRA
  185. 27      CONTINUE
  186.       WRITE(IW,42)  THET,PHI,TMP5,TMP6,GTOT,AXRAT,TILTA,ISENS,ETHM,ETHA
  187.      1,EPHM,EPHA
  188. C      GO TO 29
  189. C***
  190. C28    WRITE(IW,43)  RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA
  191.       IF(IPLP1 .NE. 3) GO TO 299
  192.       IF(IPLP3 .EQ. 0) GO TO 290
  193.       IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 1) WRITE(8,*) THET,ETHM,ETHA
  194.       IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 2) WRITE(8,*) THET,EPHM,EPHA
  195.       IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 1) WRITE(8,*) PHI,ETHM,ETHA
  196.       IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 2) WRITE(8,*) PHI,EPHM,EPHA
  197.       IF(IPLP4 .EQ. 0) GO TO 299
  198. 290   IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 1) WRITE(8,*) THET,TMP5
  199.       IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 2) WRITE(8,*) THET,TMP6
  200.       IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 3) WRITE(8,*) THET,GTOT
  201. C***
  202. C***    ADD IPLP4.EQ.4 OPTION   RWA 03 APR 89   ADD 2 LINES
  203. C***
  204.       IF(IPLP2.EQ.1.AND.IPLP4.EQ.4) WRITE(8,*) THET,PHI,TMP5,TMP6,GTOT
  205.       IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 1) WRITE(8,*) PHI,TMP5
  206.       IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 2) WRITE(8,*) PHI,TMP6
  207.       IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 3) WRITE(8,*) PHI,GTOT
  208. C***
  209. C***    ADD IPLP4.EQ.4 OPTION   RWA 03 APR 89   ADD 2 LINES
  210. C***
  211.       IF(IPLP2.EQ.1.AND.IPLP4.EQ.4) WRITE(8,*) PHI,THET,TMP5,TMP6,GTOT
  212.       GO TO 299
  213. 28      CONTINUE
  214.       WRITE(IW,43)  RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA
  215. C***
  216. C***    ADD IPLP2 = 3 FOR GROUND WAVE FIELDS  RWA 03 APR 89  ADD 11 LINES
  217. C***
  218.       IF(IPLP1.NE.3) GO TO 299
  219.       IF (IPLP3.EQ.0) GO TO 299
  220.       IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 1) WRITE(8,*) THET,ETHM,ETHA
  221.       IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 2) WRITE(8,*) THET,EPHM,EPHA
  222.       IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 3) WRITE(8,*) THET,ERDM,ERDA
  223.       IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 1) WRITE(8,*) PHI,ETHM,ETHA
  224.       IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 2) WRITE(8,*) PHI,EPHM,EPHA
  225.       IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 3) WRITE(8,*) PHI,ERDM,ERDA
  226.       IF(IPLP2 .EQ. 3 .AND. IPLP3 .EQ. 1) WRITE(8,*) RFLD,ETHM,ETHA
  227.       IF(IPLP2 .EQ. 3 .AND. IPLP3 .EQ. 2) WRITE(8,*) RFLD,EPHM,EPHA
  228.       IF(IPLP2 .EQ. 3 .AND. IPLP3 .EQ. 3) WRITE(8,*) RFLD,ERDM,ERDA
  229. 299   CONTINUE
  230. C***
  231. 29    CONTINUE
  232.       IF (IAVP.EQ.0) GO TO 30
  233.       TMP3=THETS*TA
  234.       TMP4=TMP3+DTH*TA*FLOAT(NTH-1)
  235. C      TMP3=ABS(DPH*TA*FLOAT(NPH-1)*(DCOS(TMP3)-DCOS(TMP4)))
  236.       TMP3=ABS(DPH*TA*FLOAT(NPH-1)*(COS(TMP3)-COS(TMP4)))
  237.       PINT=PINT/TMP3
  238.       TMP3=TMP3/PI
  239.       WRITE(IW,44)  PINT,TMP3
  240. 30    IF (INOR.EQ.0) GO TO 34
  241.       IF (ABS(GNOR).GT.1.E-20) GMAX=GNOR
  242.       ITMP1=(INOR-1)*2+1
  243.       ITMP2=ITMP1+1
  244.       WRITE(IW,45)  IGNTP(ITMP1),IGNTP(ITMP2),GMAX
  245.       ITMP2=NPH*NTH
  246.       IF (ITMP2.GT.NORMAX) ITMP2=NORMAX
  247.       ITMP1=(ITMP2+2)/3
  248.       ITMP2=ITMP1*3-ITMP2
  249.       ITMP3=ITMP1
  250.       ITMP4=2*ITMP1
  251.       IF (ITMP2.EQ.2) ITMP4=ITMP4-1
  252.       DO 31 I=1,ITMP1
  253.       ITMP3=ITMP3+1
  254.       ITMP4=ITMP4+1
  255.       J=(I-1)/NTH
  256.       TMP1=THETS+FLOAT(I-J*NTH-1)*DTH
  257.       TMP2=PHIS+FLOAT(J)*DPH
  258.       J=(ITMP3-1)/NTH
  259.       TMP3=THETS+FLOAT(ITMP3-J*NTH-1)*DTH
  260.       TMP4=PHIS+FLOAT(J)*DPH
  261.       J=(ITMP4-1)/NTH
  262.       TMP5=THETS+FLOAT(ITMP4-J*NTH-1)*DTH
  263.       TMP6=PHIS+FLOAT(J)*DPH
  264.       TSTOR1=GAIN(I)-GMAX
  265.       IF (I.EQ.ITMP1.AND.ITMP2.NE.0) GO TO 32
  266.       TSTOR2=GAIN(ITMP3)-GMAX
  267.       PINT=GAIN(ITMP4)-GMAX
  268. 31    WRITE(IW,46)  TMP1,TMP2,TSTOR1,TMP3,TMP4,TSTOR2,TMP5,TMP6,PINT
  269.       GO TO 34
  270. 32    IF (ITMP2.EQ.2) GO TO 33
  271.       TSTOR2=GAIN(ITMP3)-GMAX
  272.       WRITE(IW,46)  TMP1,TMP2,TSTOR1,TMP3,TMP4,TSTOR2
  273.       GO TO 34
  274. 33    WRITE(IW,46)  TMP1,TMP2,TSTOR1
  275. 34    RETURN
  276. C
  277. 35    FORMAT (///,31X,39H- - - FAR FIELD GROUND PARAMETERS - - -,//)
  278. 36    FORMAT (40X,25HRADIAL WIRE GROUND SCREEN,/,40X,I5,6H WIRES,/,40X,1
  279.      12HWIRE LENGTH=,F8.2,7H METERS,/,40X,12HWIRE RADIUS=,1P,E10.3,
  280.      27H METERS)
  281. 37    FORMAT (40X,A6,6H CLIFF,/,40X,14HEDGE DISTANCE=,F9.2,7H METERS,/,4
  282.      10X,7HHEIGHT=,F8.2,7H METERS,/,40X,15HSECOND MEDIUM -,/,40X,27HRELA
  283.      2TIVE DIELECTRIC CONST.=,F7.3,/,40X,13HCONDUCTIVITY=,1P,E10.3,
  284.      35H MHOS)
  285. 38    FORMAT(///,48X,30H- - - RADIATION PATTERNS - - -)
  286. 39    FORMAT (54X,6HRANGE=,1P,E13.6,7H METERS,/,54X,12HEXP(-JKR)/R=,
  287.      1E12.5,9H AT PHASE,0P,F7.2,8H DEGREES,/)
  288. 40    FORMAT (/,2X,14H- - ANGLES - -,7X,2A6,7HGAINS -,7X,24H- - - POLARI
  289.      1ZATION - - -,4X,20H- - - E(THETA) - - -,4X,16H- - - E(PHI) - -,2H
  290.      2-,/,2X,5HTHETA,5X,3HPHI,7X,A6,2X,A6,3X,5HTOTAL,6X,5HAXIAL,5X,4HTIL
  291.      3T,3X,5HSENSE,2(5X,9HMAGNITUDE,4X,6HPHASE ),/,2(1X,7HDEGREES,1X),3(
  292.      46X,2HDB),8X,5HRATIO,5X,4HDEG.,8X,2(6X,7HVOLTS/M,4X,7HDEGREES))
  293. 41    FORMAT (///,28X,40H - - - RADIATED FIELDS NEAR GROUND - - -,//,8X,
  294.      120H- - - LOCATION - - -,10X,16H- - E(THETA) - -,8X,14H- - E(PHI) -
  295.      2 -,8X,17H- - E(RADIAL) - -,/,7X,3HRHO,6X,3HPHI,9X,1HZ,12X,3HMAG,6X
  296.      3,5HPHASE,9X,3HMAG,6X,5HPHASE,9X,3HMAG,6X,5HPHASE,/,5X,6HMETERS,3X,
  297.      47HDEGREES,4X,6HMETERS,8X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3X,7H
  298.      5DEGREES,6X,7HVOLTS/M,3X,7HDEGREES,/)
  299. 42    FORMAT(1X,F7.2,F9.2,3X,3F8.2,F11.5,F9.2,2X,A6,2(1P,E15.5,0P,F9.2))
  300. 43    FORMAT (3X,F9.2,2X,F7.2,2X,F9.2,1X,3(3X,1P,E11.4,2X,0P,F7.2))
  301. 44    FORMAT (//,3X,19HAVERAGE POWER GAIN=,1P,E12.5,7X, 31HSOLID ANGLE U
  302.      1SED IN AVERAGING=(,0P,F7.4,16H)*PI STERADIANS.,//)
  303. 45    FORMAT (//,37X,31H- - - - NORMALIZED GAIN - - - -,//,37X,2A6,4HGAI
  304.      1N,/,38X,22HNORMALIZATION FACTOR =,F9.2,3H DB,//,3(4X,14H- - ANGLES
  305.      2 - -,6X,4HGAIN,7X),/,3(4X,5HTHETA,5X,3HPHI,8X,2HDB,8X),/,3(3X,7HDE
  306.      3GREES,2X,7HDEGREES,16X))
  307. 46    FORMAT (3(1X,2F9.2,1X,F9.2,6X))
  308.       END
  309. C
  310. C
  311. C
  312.       SUBROUTINE FFLD(CUR,THET,PHI,ETH,EPH,X,Y,Z,SI,BI,
  313.      1 SALP,AIR,AII,BIR,BII,CIR,CII,CAB,SAB,LD,LD3)
  314. C
  315. C     FFLD CALCULATES THE FAR ZONE RADIATED ELECTRIC FIELDS,
  316. C     THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED
  317. C
  318.       REAL*8 CONSX,ARG,DARG,PHX,PHY,ROX,ROY,ROZ,RRZ,ROZS,THX,THY,THZ,
  319.      1 TTHET,D,DR,EL,A,B,C,OMEGA,SILL,TOP,BOT,BOO,TOO,RR,RI
  320.       REAL*8 AIR,AII,BIR,BII,CIR,CII
  321. CLARGE: CUR
  322.       COMPLEX CUR
  323.       COMPLEX*16 ZRATI,ZRATI2,T1,FRATI
  324.       COMPLEX*16 CONST,EXA,GX,GY,GZ,CIX,CIY,CIZ,CCX,CCY,CCZ,CDP
  325.       COMPLEX*16 ZRSIN,RRV,RRH,RRV1,RRH1,RRV2,RRH2,TIX,TIY,
  326.      1 TIZ,ZSCRN,EX,EY,EZ,ETH,EPH
  327.       INTEGER*4 N1,N2,N,NP,M1,M2,M,MP,IPSYM
  328.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  329.       COMMON/GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,
  330.      1 IFAR,IPERF,T1,T2
  331.       DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
  332.       DIMENSION CAB(LD),SAB(LD),CUR(LD3),CONSX(2)
  333.       DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
  334.       EQUIVALENCE (CONST,CONSX)
  335.       DATA PI,TP,ETA/3.141592654D0,6.283185308D0,376.73/
  336.       DATA CONSX/0.,-29.97922085D0/
  337. C      PHX=-DSIN(PHI)
  338.       PHX=-SIN(PHI)
  339. C      PHY=DCOS(PHI)
  340.       PHY=COS(PHI)
  341. C      ROZ=DCOS(THET)
  342.       ROZ=COS(THET)
  343.       ROZS=ROZ
  344.       THX=ROZ*PHY
  345.       THY=-ROZ*PHX
  346. C      THZ=-DSIN(THET)
  347.       THZ=-SIN(THET)
  348.       ROX=-THZ*PHY
  349.       ROY=THZ*PHX
  350.       IF (N.EQ.0) GO TO 20
  351. C
  352. C     LOOP FOR STRUCTURE IMAGE IF ANY
  353. C
  354.       DO 19 K=1,KSYMP
  355. C
  356. C     CALCULATION OF REFLECTION COEFFECIENTS
  357. C
  358.       IF (K.EQ.1) GO TO 4
  359.       IF (IPERF.NE.1) GO TO 1
  360. C
  361. C     FOR PERFECT GROUND
  362. C
  363.       RRV=-(1.,0.)
  364.       RRH=-(1.,0.)
  365.       GO TO 2
  366. C
  367. C     FOR INFINITE PLANAR GROUND
  368. C
  369. 1     ZRSIN=CDSQRT(1.-ZRATI*ZRATI*THZ*THZ)
  370.       RRV=-(ROZ-ZRATI*ZRSIN)/(ROZ+ZRATI*ZRSIN)
  371.       RRH=(ZRATI*ROZ-ZRSIN)/(ZRATI*ROZ+ZRSIN)
  372. 2     IF (IFAR.LE.1) GO TO 3
  373. C
  374. C     FOR THE CLIFF PROBLEM, TWO REFLCTION COEFFICIENTS CALCULATED
  375. C
  376.       RRV1=RRV
  377.       RRH1=RRH
  378. C      TTHET=DTAN(THET)
  379.       TTHET=TAN(THET)
  380.       IF (IFAR.EQ.4) GO TO 3
  381.       ZRSIN=CDSQRT(1.-ZRATI2*ZRATI2*THZ*THZ)
  382.       RRV2=-(ROZ-ZRATI2*ZRSIN)/(ROZ+ZRATI2*ZRSIN)
  383.       RRH2=(ZRATI2*ROZ-ZRSIN)/(ZRATI2*ROZ+ZRSIN)
  384.       DARG=-TP*2.*CH*ROZ
  385. 3     ROZ=-ROZ
  386.       CCX=CIX
  387.       CCY=CIY
  388.       CCZ=CIZ
  389. 4     CIX=(0.,0.)
  390.       CIY=(0.,0.)
  391.       CIZ=(0.,0.)
  392. C
  393. C     LOOP OVER STRUCTURE SEGMENTS
  394. C
  395.       DO 17 I=1,N
  396.       OMEGA=-(ROX*CAB(I)+ROY*SAB(I)+ROZ*SALP(I))
  397.       EL=PI*SI(I)
  398.       SILL=OMEGA*EL
  399.       TOP=EL+SILL
  400.       BOT=EL-SILL
  401.       IF (ABS(OMEGA).LT.1.E-7) GO TO 5
  402.       A=2.*DSIN(SILL)/OMEGA
  403.       GO TO 6
  404. 5     A=(2.-OMEGA*OMEGA*EL*EL/3.)*EL
  405. 6     IF (ABS(TOP).LT.1.E-7) GO TO 7
  406.       TOO=DSIN(TOP)/TOP
  407.       GO TO 8
  408. 7     TOO=1.-TOP*TOP/6.
  409. 8     IF (ABS(BOT).LT.1.E-7) GO TO 9
  410.       BOO=DSIN(BOT)/BOT
  411.       GO TO 10
  412. 9     BOO=1.-BOT*BOT/6.
  413. 10    B=EL*(BOO-TOO)
  414.       C=EL*(BOO+TOO)
  415.       RR=A*AIR(I)+B*BII(I)+C*CIR(I)
  416.       RI=A*AII(I)-B*BIR(I)+C*CII(I)
  417.       ARG=TP*(X(I)*ROX+Y(I)*ROY+Z(I)*ROZ)
  418.       IF (K.EQ.2.AND.IFAR.GE.2) GO TO 11
  419.       EXA=DCMPLX(DCOS(ARG),DSIN(ARG))*DCMPLX(RR,RI)
  420. C
  421. C     SUMMATION FOR FAR FIELD INTEGRAL
  422. C
  423.       CIX=CIX+EXA*CAB(I)
  424.       CIY=CIY+EXA*SAB(I)
  425.       CIZ=CIZ+EXA*SALP(I)
  426.       GO TO 17
  427. C
  428. C     CALCULATION OF IMAGE CONTRIBUTION IN CLIFF AND GROUND SCREEN
  429. C     PROBLEMS.
  430. C
  431. 11    DR=Z(I)*TTHET
  432. C
  433. C     SPECULAR POINT DISTANCE
  434. C
  435.       D=DR*PHY+X(I)
  436.       IF (IFAR.EQ.2) GO TO 13
  437.       D=DSQRT(D*D+(Y(I)-DR*PHX)**2)
  438.       IF (IFAR.EQ.3) GO TO 13
  439.       IF ((SCRWL-D).LT.0.) GO TO 12
  440. C
  441. C     RADIAL WIRE GROUND SCREEN REFLECTION COEFFICIENT
  442. C
  443.       D=D+T2
  444.       ZSCRN=T1*D*DLOG(D/T2)
  445.       ZSCRN=(ZSCRN*ZRATI)/(ETA*ZRATI+ZSCRN)
  446.       ZRSIN=CDSQRT(1.-ZSCRN*ZSCRN*THZ*THZ)
  447.       RRV=(ROZ+ZSCRN*ZRSIN)/(-ROZ+ZSCRN*ZRSIN)
  448.       RRH=(ZSCRN*ROZ+ZRSIN)/(ZSCRN*ROZ-ZRSIN)
  449.       GO TO 16
  450. 12    IF (IFAR.EQ.4) GO TO 14
  451.       IF (IFAR.EQ.5) D=DR*PHY+X(I)
  452. 13    IF ((CL-D).LE.0.) GO TO 15
  453. 14    RRV=RRV1
  454.       RRH=RRH1
  455.       GO TO 16
  456. 15    RRV=RRV2
  457.       RRH=RRH2
  458.       ARG=ARG+DARG
  459. 16    EXA=DCMPLX(DCOS(ARG),DSIN(ARG))*DCMPLX(RR,RI)
  460. C
  461. C     CONTRIBUTION OF EACH IMAGE SEGMENT MODIFIED BY REFLECTION COEF. ,
  462. C     FOR CLIFF AND GROUND SCREEN PROBLEMS
  463. C
  464.       TIX=EXA*CAB(I)
  465.       TIY=EXA*SAB(I)
  466.       TIZ=EXA*SALP(I)
  467.       CDP=(TIX*PHX+TIY*PHY)*(RRH-RRV)
  468.       CIX=CIX+TIX*RRV+CDP*PHX
  469.       CIY=CIY+TIY*RRV+CDP*PHY
  470.       CIZ=CIZ-TIZ*RRV
  471. 17    CONTINUE
  472.       IF (K.EQ.1) GO TO 19
  473.       IF (IFAR.GE.2) GO TO 18
  474. C
  475. C     CALCULATION OF CONTRIBUTION OF STRUCTURE IMAGE FOR INFINITE GROUND
  476. C
  477.       CDP=(CIX*PHX+CIY*PHY)*(RRH-RRV)
  478.       CIX=CCX+CIX*RRV+CDP*PHX
  479.       CIY=CCY+CIY*RRV+CDP*PHY
  480.       CIZ=CCZ-CIZ*RRV
  481.       GO TO 19
  482. 18    CIX=CIX+CCX
  483.       CIY=CIY+CCY
  484.       CIZ=CIZ+CCZ
  485. 19    CONTINUE
  486.       IF (M.GT.0) GO TO 21
  487.       ETH=(CIX*THX+CIY*THY+CIZ*THZ)*CONST
  488.       EPH=(CIX*PHX+CIY*PHY)*CONST
  489.       RETURN
  490. 20    CIX=(0.,0.)
  491.       CIY=(0.,0.)
  492.       CIZ=(0.,0.)
  493. 21    ROZ=ROZS
  494. C
  495. C     ELECTRIC FIELD COMPONENTS
  496. C
  497.       RFL=-1.
  498.       DO 25 IP=1,KSYMP
  499.       RFL=-RFL
  500.       RRZ=ROZ*RFL
  501.       CALL FFLDS(CUR(N+1),GX,GY,GZ,X,Y,Z,BI,ROX,ROY,RRZ,LD)
  502.       IF (IP.EQ.2) GO TO 22
  503.       EX=GX
  504.       EY=GY
  505.       EZ=GZ
  506.       GO TO 25
  507. 22    IF (IPERF.NE.1) GO TO 23
  508.       GX=-GX
  509.       GY=-GY
  510.       GZ=-GZ
  511.       GO TO 24
  512. 23    RRV=CDSQRT(1.-ZRATI*ZRATI*THZ*THZ)
  513.       RRH=ZRATI*ROZ
  514.       RRH=(RRH-RRV)/(RRH+RRV)
  515.       RRV=ZRATI*RRV
  516.       RRV=-(ROZ-RRV)/(ROZ+RRV)
  517.       ETH=(GX*PHX+GY*PHY)*(RRH-RRV)
  518.       GX=GX*RRV+ETH*PHX
  519.       GY=GY*RRV+ETH*PHY
  520.       GZ=GZ*RRV
  521. 24    EX=EX+GX
  522.       EY=EY+GY
  523.       EZ=EZ-GZ
  524. 25    CONTINUE
  525.       EX=EX+CIX*CONST
  526.       EY=EY+CIY*CONST
  527.       EZ=EZ+CIZ*CONST
  528.       ETH=EX*THX+EY*THY+EZ*THZ
  529.       EPH=EX*PHX+EY*PHY
  530.       RETURN
  531.       END
  532. C
  533. C
  534. C
  535.       SUBROUTINE GFLD (RHO,PHI,RZ,ETH,EPI,ERD,UX,KSYMP,LD,
  536.      1 LD3,X,Y,Z,SI,BI,SALP,AIR,AII,BIR,BII,CIR,CII,CUR,CAB,SAB)
  537. C
  538. C     GFLD COMPUTES THE RADIATED FIELD INCLUDING GROUND WAVE.
  539. C
  540.       REAL*8 PI,TP,R,ARG,R1,R2,ZMH,ZPH,PHX,PHY,RX,RY,RIX,RIY,RIZ
  541.       REAL*8 RHS,RHP,RHX,RHY,CALP,CBET,SBET,CPH,SPH,EL,RNX,RNY,RNZ
  542.       REAL*8 RXYZ,OMEGA,SILL,TOP,BOT,BOO,TOO,A,B,C,RR,RI,THX,THY,THZ
  543.       REAL*8 AIR,AII,BIR,BII,CIR,CII
  544. CLARGE: CUR
  545.       COMPLEX CUR
  546.       COMPLEX*16 U,U2,XX1,XX2,EXA,ERV,EZV,ERH,EZH,EPH
  547.       COMPLEX*16 CIX,CIY,CIZ,EX,EY,EPI,ETH,ERD,UX
  548.       INTEGER*4 N1,N2,N,NP,M1,M2,M,MP,IPSYM
  549.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  550.       COMMON/GWAV/ U,U2,XX1,XX2,R1,R2,ZMH,ZPH
  551.       DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
  552.       DIMENSION CAB(LD),SAB(LD),CUR(LD3)
  553.       DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
  554.       DATA PI,TP/3.141592654D0,6.283185308D0/
  555. C      R=DSQRT(RHO*RHO+RZ*RZ)
  556.       R=SQRT(RHO*RHO+RZ*RZ)
  557.       IF (KSYMP.EQ.1) GO TO 1
  558. C      IF (CABS(UX).GT..5) GO TO 1
  559.       IF (ZABS(UX).GT..5) GO TO 1
  560.       IF (R.GT.1.D+5) GO TO 1
  561.       GO TO 4
  562. C
  563. C     COMPUTATION OF SPACE WAVE ONLY
  564. C
  565. 1     IF (RZ.LT.1.E-20) GO TO 2
  566. C      THET=DATAN(RHO/RZ)
  567.       THET=ATAN(RHO/RZ)
  568.       GO TO 3
  569. 2     THET=PI*.5
  570. 3     CALL FFLD(CUR,THET,PHI,ETH,EPI,X,Y,Z,SI,BI,
  571.      1 SALP,AIR,AII,BIR,BII,CIR,CII,CAB,SAB,LD,LD3)
  572.       ARG=-TP*R
  573.       EXA=DCMPLX(DCOS(ARG),DSIN(ARG))/R
  574.       ETH=ETH*EXA
  575.       EPI=EPI*EXA
  576.       ERD=(0.,0.)
  577.       RETURN
  578. C
  579. C     COMPUTATION OF SPACE AND GROUND WAVES.
  580. C
  581. 4     U=UX
  582.       U2=U*U
  583. C      PHX=-DSIN(PHI)
  584.       PHX=-SIN(PHI)
  585. C      PHY=DCOS(PHI)
  586.       PHY=COS(PHI)
  587.       RX=RHO*PHY
  588.       RY=-RHO*PHX
  589.       CIX=(0.,0.)
  590.       CIY=(0.,0.)
  591.       CIZ=(0.,0.)
  592. C
  593. C     SUMMATION OF FIELD FROM INDIVIDUAL SEGMENTS
  594. C
  595.       DO 17 I=1,N
  596.       DX=CAB(I)
  597.       DY=SAB(I)
  598.       DZ=SALP(I)
  599.       RIX=RX-X(I)
  600.       RIY=RY-Y(I)
  601.       RHS=RIX*RIX+RIY*RIY
  602.       RHP=DSQRT(RHS)
  603.       IF (RHP.LT.1.E-6) GO TO 5
  604.       RHX=RIX/RHP
  605.       RHY=RIY/RHP
  606.       GO TO 6
  607. 5     RHX=1.
  608.       RHY=0.
  609. 6     CALP=1.-DZ*DZ
  610.       IF (CALP.LT.1.E-6) GO TO 7
  611.       CALP=DSQRT(CALP)
  612.       CBET=DX/CALP
  613.       SBET=DY/CALP
  614.       CPH=RHX*CBET+RHY*SBET
  615.       SPH=RHY*CBET-RHX*SBET
  616.       GO TO 8
  617. 7     CPH=RHX
  618.       SPH=RHY
  619. 8     EL=PI*SI(I)
  620.       RFL=-1.
  621. C
  622. C     INTEGRATION OF (CURRENT)*(PHASE FACTOR) OVER SEGMENT AND IMAGE FOR
  623. C     CONSTANT, SINE, AND COSINE CURRENT DISTRIBUTIONS
  624. C
  625.       DO 16 K=1,2
  626.       RFL=-RFL
  627.       RIZ=RZ-Z(I)*RFL
  628.       RXYZ=DSQRT(RIX*RIX+RIY*RIY+RIZ*RIZ)
  629.       RNX=RIX/RXYZ
  630.       RNY=RIY/RXYZ
  631.       RNZ=RIZ/RXYZ
  632.       OMEGA=-(RNX*DX+RNY*DY+RNZ*DZ*RFL)
  633.       SILL=OMEGA*EL
  634.       TOP=EL+SILL
  635.       BOT=EL-SILL
  636.       IF(DABS(OMEGA).LT.1.D-7) GO TO 9
  637.       A=2.*DSIN(SILL)/OMEGA
  638.       GO TO 10
  639. 9     A=(2.-OMEGA*OMEGA*EL*EL/3.)*EL
  640. 10    IF(DABS(TOP).LT.1.D-7) GO TO 11
  641.       TOO=DSIN(TOP)/TOP
  642.       GO TO 12
  643. 11    TOO=1.-TOP*TOP/6.
  644. 12    IF(DABS(BOT).LT.1.D-7) GO TO 13
  645.       BOO=DSIN(BOT)/BOT
  646.       GO TO 14
  647. 13    BOO=1.-BOT*BOT/6.
  648. 14    B=EL*(BOO-TOO)
  649.       C=EL*(BOO+TOO)
  650.       RR=A*AIR(I)+B*BII(I)+C*CIR(I)
  651.       RI=A*AII(I)-B*BIR(I)+C*CII(I)
  652.       ARG=TP*(X(I)*RNX+Y(I)*RNY+Z(I)*RNZ*RFL)
  653.       EXA=DCMPLX(DCOS(ARG),DSIN(ARG))*DCMPLX(RR,RI)/TP
  654.       IF (K.EQ.2) GO TO 15
  655.       XX1=EXA
  656.       R1=RXYZ
  657.       ZMH=RIZ
  658.       GO TO 16
  659. 15    XX2=EXA
  660.       R2=RXYZ
  661.       ZPH=RIZ
  662. 16    CONTINUE
  663. C
  664. C     CALL SUBROUTINE TO COMPUTE THE FIELD OF SEGMENT INCLUDING
  665. C     GROUND WAVE.
  666. C
  667.       CALL GWAVE (ERV,EZV,ERH,EZH,EPH)
  668.       ERH=ERH*CPH*CALP+ERV*DZ
  669.       EPH=EPH*SPH*CALP
  670.       EZH=EZH*CPH*CALP+EZV*DZ
  671.       EX=ERH*RHX-EPH*RHY
  672.       EY=ERH*RHY+EPH*RHX
  673.       CIX=CIX+EX
  674.       CIY=CIY+EY
  675. 17    CIZ=CIZ+EZH
  676.       ARG=-TP*R
  677.       EXA=DCMPLX(DCOS(ARG),DSIN(ARG))
  678.       CIX=CIX*EXA
  679.       CIY=CIY*EXA
  680.       CIZ=CIZ*EXA
  681.       RNX=RX/R
  682.       RNY=RY/R
  683.       RNZ=RZ/R
  684.       THX=RNZ*PHY
  685.       THY=-RNZ*PHX
  686.       THZ=-RHO/R
  687.       ETH=CIX*THX+CIY*THY+CIZ*THZ
  688.       EPI=CIX*PHX+CIY*PHY
  689.       ERD=CIX*RNX+CIY*RNY+CIZ*RNZ
  690.       RETURN
  691.       END
  692. C
  693. C
  694. C
  695.       SUBROUTINE FFLDS(SCUR,EX,EY,EZ,XS,YS,ZS,S,ROX,ROY,ROZ,LD)
  696. C     CALCULATES THE XYZ COMPONENTS OF THE ELECTRIC FIELD DUE TO
  697. C     SURFACE CURRENTS
  698.       REAL*8 TPI,CONSX,ARG,ROX,ROY,ROZ
  699. CLARGE: SCUR
  700.       COMPLEX SCUR
  701.       COMPLEX*16 CONS,CT,EX,EY,EZ
  702.       INTEGER*4 N1,N2,N,NP,M1,M2,M,MP,IPSYM
  703.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  704.       DIMENSION XS(LD),YS(LD),ZS(LD),S(LD),CONSX(2),SCUR(1)
  705.       EQUIVALENCE (CONS,CONSX)
  706.       DATA TPI/6.283185308D0/,CONSX/0.,188.365D0/
  707.       EX=(0.,0.)
  708.       EY=(0.,0.)
  709.       EZ=(0.,0.)
  710.       I=LD+1
  711.       DO 1 J=1,M
  712.       I=I-1
  713.       ARG=TPI*(ROX*XS(I)+ROY*YS(I)+ROZ*ZS(I))
  714.       CT=DCMPLX(DCOS(ARG)*S(I),DSIN(ARG)*S(I))
  715.       K=3*J
  716.       EX=EX+SCUR(K-2)*CT
  717.       EY=EY+SCUR(K-1)*CT
  718.       EZ=EZ+SCUR(K)*CT
  719. 1     CONTINUE
  720.       CT=ROX*EX+ROY*EY+ROZ*EZ
  721.       EX=CONS*(CT*ROX-EX)
  722.       EY=CONS*(CT*ROY-EY)
  723.       EZ=CONS*(CT*ROZ-EZ)
  724.       RETURN
  725.       END
  726.